home *** CD-ROM | disk | FTP | other *** search
/ LOGIC Apps / Logic-APPLE_II_APPS.iso / pc / LOGIC Apple II 5.25" Library - DOS Part 7 / DOS226.dsk / DIMMER.bas < prev    next >
BASIC Source File  |  2012-02-16  |  5KB  |  89 lines
  1. 0  REM FAMILY ROOTS: DIMMER PROGRAM. COPYRIGHT 1984 BY STEPHEN C. VORENBERG.
  2. 10 B = 1: ONERR  GOTO 30
  3. 20  PRINT  CHR$(4)"OPEN CONTROLS": PRINT  CHR$(4)"READ CONTROLS": FOR I = 1 TO 8: INPUT A: NEXT : PRINT  CHR$(4)"CLOSE":B = 0
  4. 30  POKE 216,0: IF B = 1  OR A =  PEEK(115) +256 * PEEK(116)  THEN  PRINT  CHR$(4)"RUN START"
  5. 55  CLEAR : GOSUB 5000
  6. 80  IF   NOT Q(2)  AND Q(30)  THEN  GOSUB 850: PRINT  CHR$(4)"PR#"Q(43)
  7. 90  GOSUB 6000: GOSUB 12500:LO = 0:CZ$ = Q$(22):SP$ =  CHR$(15): IF Q(41) >1  THEN SP$ =  CHR$(20)
  8. 150  ONERR  GOTO 300
  9. 160  IF Q(2)  OR   NOT Q(30)  THEN 195
  10. 193  IF Q(40)  THEN  GOSUB 850: PRINT  CHR$(21)
  11. 194  GOSUB 500: PRINT  SPC( 14)"LOADING NEXT MODULE"
  12. 195  PRINT  CHR$(4)"BLOAD CHAIN,A520"
  13. 197  POKE 216,0
  14. 200  CALL 520"PROGRAMS"
  15. 300  POKE 216,0:I =  PEEK(222): IF I < >8  THEN  PRINT "ERROR # "I". PLEASE SEE DOS MANUAL.": END 
  16. 500  GOSUB 850: FOR I = 1 TO 7: PRINT : NEXT : INVERSE : PRINT "PLEASE WAIT";: NORMAL : PRINT "....": PRINT 
  17. 510  RETURN 
  18. 850  PRINT : IF Q(43) = 0  OR Q(40)  THEN  HOME : RETURN 
  19. 855  PRINT  CHR$(12): RETURN 
  20. 5000  ONERR  GOTO 5900
  21. 5010  DIM Q(64),Q$(22)
  22. 5020  PRINT  CHR$(4)"OPEN CONFIGURATION": PRINT  CHR$(4)"READ CONFIGURATION": FOR I = 1 TO 64: INPUT Q(I): NEXT 
  23. 5030  FOR I = 1 TO 22:Q$(I) = ""
  24. 5040 K = 0: GET A$: IF A$ =  CHR$(127)  THEN A$ =  CHR$(0)
  25. 5042  IF A$ =  CHR$(126)  THEN A$ =  CHR$(13):K = 1
  26. 5045  IF A$ < > CHR$(13)  OR K = 1  THEN Q$(I) = Q$(I) +A$: GOTO 5040
  27. 5050  NEXT : INPUT A$: PRINT  CHR$(4)"CLOSE": POKE 216,0: RETURN 
  28. 5900 A =  PEEK(222): IF A < >5  AND A < >6  AND A < >8  THEN 5920
  29. 5920  PRINT "ERROR # "A". PLEASE SEE DOS MANUAL.": END 
  30. 6000  DIM C$(Q(18)),EX$(Q(17)),MI$(4,Q(19)),RC$(21):A = Q(21): IF A <Q(24)  THEN A = Q(24)
  31. 6004  IF A <Q(36) *Q(37)  THEN A = Q(36) *Q(37)
  32. 6010  DIM SV(A),OP(20),OP$(20),G(12):G(10) = A:G(8) =  PEEK(115) +256 * PEEK(116) +1
  33. 6015 I = Q(18): IF I <19  THEN I = 19
  34. 6016  IF I <Q(20)  THEN I = Q(20)
  35. 6017 J = Q(20): IF J <11  THEN J = 11
  36. 6020  DIM OD(I),T(J +1),OE(I)
  37. 6022 I = 31: IF Q(18) >I  THEN I = Q(18)
  38. 6025  DIM EM$(I)
  39. 6030  DIM MT$(12): FOR I = 1 TO 12: READ MT$(I): NEXT 
  40. 6040  DIM CH$(4),H$(9),H1$(5),VR$(10),WR$(4)
  41. 6042 I = Q(18): IF I <31  THEN I = 31: REM SEARCH AND TEXT
  42. 6043 J = Q(20): IF J <Q(42)  THEN J = Q(42)
  43. 6044  IF J <Q(19)  THEN J = Q(19)
  44. 6045  DIM S$(I,J),G$(Q(18)): GOSUB 7000
  45. 6046  IF Q(9) = 0  THEN G(0) = 976
  46. 6047  IF Q(9) <2  THEN G(0) = 25
  47. 6049  IF Q(9) = 2  THEN G(0) =  PEEK(115) +256 * PEEK(116) +12
  48. 6050  DIM NA$(Q(36) *Q(37)),PA(Q(37) -1),SC(Q(37) -1),WH(Q(8),3),CT(Q(37) -1),PT(Q(37) -1)
  49. 6055  FOR I = 1 TO Q(8): FOR J = 2 TO 3:WH(I,J) = Q(47 +2 *(I -1) +J): NEXT : NEXT 
  50. 6100  DIM DF(Q(44) +11),FP(21)
  51. 6110  IF Q(44) = 0  THEN  RETURN 
  52. 6120  FOR I = 1 TO Q(44):FP(I +11) =  VAL( RIGHT$(Q$(I +11),1)) +11: IF FP(I +11) = 11  THEN FP(I +11) = 0
  53. 6125 A =  LEN(Q$(I +11)):DF(I +11) =  VAL( MID$ (Q$(I +11),A -1,1)): IF A >2  THEN Q$(I +11) =  LEFT$(Q$(I +11),A -2): GOTO 6130
  54. 6127 Q$(I +11) = ""
  55. 6130  NEXT : GOSUB 7110: RETURN 
  56. 7000  IF Q(44) = 0  THEN  RETURN 
  57. 7005 B$ = "SEX"
  58. 7010  FOR I = 1 TO Q(44):AA = 0:J = I +11: IF  LEN(Q$(J)) <5  THEN 7100
  59. 7015  IF  LEN(Q$(J)) >5  AND  MID$ (Q$(J),4,1) < >" "  THEN 7100
  60. 7020 AA = 1: FOR K = 1 TO 3:A$ =  MID$ (Q$(J),K,1): IF  ASC(A$) >95  THEN A$ =  CHR$( ASC(A$) -32)
  61. 7030  IF A$ < > MID$ (B$,K,1)  THEN AA = 0:K = 3
  62. 7040  NEXT : IF (AA)  THEN I = Q(44):AA = J
  63. 7100  NEXT :G(9) = AA: RETURN 
  64. 7110 KK = 0: FOR I = 12 TO 11 +Q(44): IF  LEN(Q$(I)) <3  THEN 7135
  65. 7112 AA = 0: FOR J = 1 TO  LEN(Q$(I)) -2:A$ =  MID$ (Q$(I),J,3)
  66. 7120  IF A$ < >"BUR"  AND A$ < >"Bur"  AND A$ < >"bur"  THEN 7130
  67. 7122  IF J = 1  THEN 7128
  68. 7124  IF  MID$ (Q$(I),J -1,1) < >" "  THEN 7130
  69. 7128 KK = KK +1:OD(KK) = I:J = Q(28)
  70. 7130  NEXT 
  71. 7135  NEXT : IF KK = 0  THEN G(11) = 0: GOTO 7210
  72. 7140  IF KK < >2  THEN 7160
  73. 7150 I = 1: IF DF(OD(2)) = 1  THEN I = 2
  74. 7155 G(11) = OD(I): GOTO 7210
  75. 7160 AA = 0: FOR I = 1 TO KK: IF DF(OD(I)) = 1  THEN AA = I
  76. 7165  NEXT : IF AA >0  THEN G(11) = OD(AA): GOTO 7210
  77. 7170 G(11) = 21:FP(21) = OD(1)
  78. 7210 AA = 0: FOR I = 12 TO 11 +Q(44):A$ =  LEFT$(Q$(I),3)
  79. 7220  IF A$ = "CHR"  OR A$ = "Chr"  OR A$ = "chr"  THEN AA = I:I = 11 +Q(44)
  80. 7230  NEXT :G(12) = AA: RETURN 
  81. 10000  DATA Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec
  82. 12500  IF Q(2)  THEN 12505
  83. 12501  IF   NOT Q(30)  THEN DY$ = Q$(3): RETURN 
  84. 12502  GOSUB 850: PRINT : INPUT "WHAT IS TODAY'S DATE? ";DY$: RETURN 
  85. 12505  PRINT  CHR$(4)"IN#"Q(5): PRINT  CHR$(4)"PR#"Q(5): PRINT Q$(7);: INPUT DY$: PRINT  CHR$(4)"IN#0": IF Q(13)  THEN A$ =  MID$ (DY$,Q(13),Q(21))
  86. 12510 DY$ =  MID$ (DY$,Q(11),Q(12) -Q(11) +1): IF   NOT Q(13)  THEN DY$ = DY$ +"/" +Q$(3)
  87. 12520  IF Q(13)  THEN DY$ = DY$ +"/" +A$
  88. 12530  IF Q(25)  THEN DY$ =  MID$ (DY$,4,3) + MID$ (DY$,1,3) + RIGHT$(DY$,4)
  89. 12540  PRINT  CHR$(4)"PR#"Q(43): RETURN